
(in-package :cl-user)

(defpackage :html
    (:use :common-lisp
          :common-utils
          :macro-utilities)
    (:export :with-html-output
             :in-html-style
             :define-html-macro
             :html
             :emit-html
             :&attributes))

(in-package :html)

(defvar *html-output* *standard-output*)
(defvar *pretty* t)
(defvar *html-pretty-printer* nil)

(defun self-evaluating-p (form)
    (and (atom form) (if (symbolp form) (keywordp form) t)))

(defun cons-form-p (form &optional (test #'keywordp))
    (and (consp form)
         (or (funcall test (car form))
             (and (consp (car form)) (funcall test (caar form))))))

(defun parse-cons-form (sexp)
    (if (consp (first sexp))
        (parse-explicit-attributes-sexp sexp)
        (parse-implicit-attributes-sexp sexp)))

(defun parse-explicit-attributes-sexp (sexp)
    (destructuring-bind ((tag &rest attributes) &body body) sexp
        (values tag attributes body)))

(defun parse-implicit-attributes-sexp (sexp)
    (loop with tag = (first sexp)
          for rest on (rest sexp) by #'cddr
          while (and (keywordp (first rest)) (second rest))
          when (second rest)
              collect (first rest) into attributes and
              collect (second rest) into attributes
          end
          finally (return (values tag attributes rest))))

(defun escape-char (char)
    (case char
        (#\& "&amp;")
        (#\< "&lt;")
        (#\> "&gt;")
        (#\' "&apos;")
        (#\" "&quot;")
        (t (format nil "&#~d;" (char-code char)))))

(defun escape (in to-escape)
    (flet ((needs-escape-p (char) (find char to-escape)))
        (with-output-to-string (out)
            (loop for start = 0 then (1+ pos)
                  for pos = (position-if #'needs-escape-p in :start start)
                  do (write-sequence in out :start start :end pos)
                  when pos do (write-sequence (escape-char (char in pos)) out)
                  while pos))))

(defparameter *element-escapes* "<>&")
(defparameter *attribute-escapes* "<>&\"'")

(defvar *escapes* *element-escapes*)

(defclass indenting-printer ()
    ((out                 :accessor out  :initarg :out)
     (beginning-of-line-p :accessor beginning-of-line-p :initform t)
     (indentation         :accessor indentation         :initform 0)
     (indenting-p         :accessor indenting-p         :initform t)))

(defun emit(ip string)
    (loop for start = 0 then (1+ pos)
          for pos = (position #\Newline string :start start)
          do (emit/no-newlines ip string :start start :end pos)
          when pos do (emit-newline ip)
          while pos))

(defun emit/no-newlines (ip string &key (start 0) end)
    (indent-if-necessary ip)
    (write-sequence string (out ip) :start start :end end)
    (unless (zerop (- (or end (length string)) start))
        (setf (beginning-of-line-p ip) nil)))

(defun indent-if-necessary (ip)
    (when (and (beginning-of-line-p ip) (indenting-p ip))
        (loop repeat (indentation ip) do (write-char #\Space (out ip)))
        (setf (beginning-of-line-p ip) nil)))

(defun emit-newline (ip)
    (write-char #\Newline (out ip))
    (setf (beginning-of-line-p ip) t))

(defun emit-freshline (ip)
    (unless (beginning-of-line-p ip) (emit-newline ip)))

(defgeneric raw-string (processor string &optional newlines-p))
(defgeneric newline (processor))
(defgeneric freshline (processor))
(defgeneric indent (processor))
(defgeneric unindent (processor))
(defgeneric toggle-indenting (processor))
(defgeneric embed-value (processor value))
(defgeneric embed-code (processor code))

(defclass html-pretty-printer ()
    ((printer :accessor printer :initarg :printer)
     (tab-width :accessor tab-width :initarg :tab-width :initform 2)))

(defmethod raw-string ((pp html-pretty-printer) string &optional newlines-p)
  (if newlines-p
      (emit (printer pp) string)
      (emit/no-newlines (printer pp) string)))

(defmethod newline ((pp html-pretty-printer))
    (emit-newline (printer pp)))

(defmethod freshline ((pp html-pretty-printer))
    (when *pretty* (emit-freshline (printer pp))))

(defmethod indent ((pp html-pretty-printer))
    (when *pretty* 
        (incf (indentation (printer pp)) (tab-width pp))))

(defmethod unindent ((pp html-pretty-printer))
    (when *pretty* 
        (decf (indentation (printer pp)) (tab-width pp))))

(defmethod toggle-indenting ((pp html-pretty-printer))
    (when *pretty* 
        (with-slots (indenting-p) (printer pp)
            (setf indenting-p (not indenting-p)))))

(define-condition embedded-lisp-in-interpreter (error)
    ((form :initarg :form :reader form)))

(define-condition value-in-interpreter (embedded-lisp-in-interpreter) ()
    (:report
        (lambda (c s)
            (format s "Can't embed values when interpreting. Value: ~s" 
                      (form c)))))

(define-condition code-in-interpreter (embedded-lisp-in-interpreter) ()
    (:report
        (lambda (c s)
            (format s "Can't embed code when interpreting. Code: ~s"
                      (form c)))))


(defmethod embed-value ((pp html-pretty-printer) value)
    (restart-case (error 'value-in-interpreter :form value)
        (evaluate ()
            :report 
                (lambda (s) 
                    (format s "EVAL ~s in null lexical environment." value))
            (raw-string pp (escape (any->string (eval value)) *escapes*) t))))

(defmethod embed-code ((pp html-pretty-printer) code)
    (restart-case (error 'code-in-interpreter :form code)
        (evaluate ()
            :report
                (lambda (s)
                    (format s "EVAL ~s in null lexical environment." code))
            (eval code))))

(defun evaluate (&optional condition)
    (declare (ignorable condition))
    (invoke-restart 'evaluate))

(defun eval-dynamic-variables (&optional condition)
    (when (and (symbolp (form condition)) (boundp (form condition)))
        (evaluate)))

(defun eval-code (&optional condition)
    (when (consp (form condition))
        (evaluate)))

(defmacro with-dynamic-evaluation ((&key values code) &body body)
    `(handler-bind 
        (,@(if values `((value-in-interpreter #'evaluate)))
         ,@(if code `((code-in-interpreter #'evaluate))))
        ,@body))

(defun process (processor form)
    (cond ((special-form-p form) (process-special-form processor form))
          ((macro-form-p form) (process processor (expand-macro-form form)))
          ((sexp-html-p form) (process-sexp-html processor form))
          ((consp form) (embed-code processor form))
          (t (embed-value processor form))))

(defun sexp-html-p (form)
    (or (self-evaluating-p form) (cons-form-p form)))

(defun process-sexp-html (processor form)
    (if (self-evaluating-p form)
        (raw-string processor (escape (any->string form) *escapes*) t)
        (process-cons-sexp-html processor form)))

(defparameter *block-elements*
    '(:body :colgroup :dl :fieldset :form :head :html :map :noscript :object
      :ol :optgroup :pre :script :select :style :table :tbody :tfoot :thead
      :tr :ul))

(defparameter *paragraph-elements*
    '(:area :base :blockquote :br :button :caption :col :dd :div :dt :h1
      :h2 :h3 :h4 :h5 :h6 :hr :input :li :link :meta :option :p :param
      :td :textarea :th :title))

(defparameter *inline-elements*
    '(:a :abbr :acronym :address :b :bdo :big :cite :code :del :dfn :em
      :i :img :ins :kbd :lable :legend :q :samp :small :span :strong :sub
      :sup :tt :var))

(defparameter *empty-elements*
    '(:area :base :br :col :hr :img :input :link :meta :param))

(defparameter *preserve-whitespace-elements*
    '(:pre :script :style))

(defparameter *xhtml* nil)

(defun block-element-p (tag) (find tag *block-elements*))
(defun paragraph-element-p (tag) (find tag *paragraph-elements*))
(defun empty-element-p (tag) (find tag *empty-elements*))
(defun preserve-whitespace-p (tag) (find tag *preserve-whitespace-elements*))

(defun process-cons-sexp-html (processor form)
    (when (string= *escapes* *attribute-escapes*)
        (error "Can't use cons forms in attributes: ~a" form))
    (multiple-value-bind (tag attributes body) (parse-cons-form form)
        (emit-open-tag processor tag body attributes)
        (emit-element-body processor tag body)
        (emit-close-tag processor tag body)))

(defun emit-open-tag (processor tag body-p attributes)
    (when (or (paragraph-element-p tag) (block-element-p tag))
        (freshline processor))
    (raw-string processor (format nil "<~(~a~)" tag))
    (emit-attributes processor attributes)
    (raw-string processor (if (and *xhtml* (not body-p)) "/>" ">")))

(defun emit-attributes (processor attributes)
    (loop for (k v) on attributes by #'cddr do
        (raw-string processor (format nil "~(~a~)='" k))
        (let ((*escapes* *attribute-escapes*))
            (process processor (if (eql v t) (string-downcase k) v)))
        (raw-string processor "'")))

(defun emit-element-body (processor tag body)
    (when (block-element-p tag)
        (freshline processor)
        (indent processor))
    (when (preserve-whitespace-p tag) (toggle-indenting processor))
    (dolist (item body) (process processor item))
    (when (preserve-whitespace-p tag) (toggle-indenting processor))
    (when (block-element-p tag)
        (unindent processor)
        (freshline processor)))

(defun emit-close-tag (processor tag body-p)
    (unless (and (or *xhtml* (empty-element-p tag)) (not body-p))
        (raw-string processor (format nil "</~(~a~)>" tag)))
    (when (or (paragraph-element-p tag) (block-element-p tag))
        (freshline processor)))

(defun emit-html (sexp) (process (get-pretty-printer) sexp))

(defun get-pretty-printer (&optional (tab-width 2))
    (or *html-pretty-printer*
        (make-instance 'html-pretty-printer
            :printer (make-instance 'indenting-printer :out *html-output*)
            :tab-width tab-width)))

(defmacro with-html-output ((stream &key (pretty *pretty*)) &body body)
    `(let* ((*html-output* ,stream) (*pretty* ,pretty))
        ,@body))

(defun make-op-buffer ()
    (make-array 10 :adjustable t :fill-pointer 0))

(defun push-op (op ops-buffer)
    (vector-push-extend op ops-buffer))

(defclass html-compiler ()
    ((ops :accessor ops :initform (make-op-buffer))))

(defmethod raw-string ((compiler html-compiler) string &optional newlines-p)
   (push-op `(:raw-string ,string ,newlines-p) (ops compiler)))

(defmethod newline ((compiler html-compiler))
    (push-op '(:newline) (ops compiler)))

(defmethod freshline ((compiler html-compiler))
    (push-op '(:freshline) (ops compiler)))

(defmethod indent ((compiler html-compiler))
    (push-op '(:indent) (ops compiler)))

(defmethod unindent ((compiler html-compiler))
    (push-op '(:unindent) (ops compiler)))

(defmethod toggle-indenting ((compiler html-compiler))
    (push-op '(:toggle-indenting) (ops compiler)))

(defmethod embed-value ((compiler html-compiler) value)
    (push-op `(:embed-value ,value ,*escapes*) (ops compiler)))

(defmethod embed-code ((compiler html-compiler) code)
    (push-op `(:embed-code ,code) (ops compiler)))

(defun sexp->ops (body)
    (loop with compiler = (make-instance 'html-compiler)
        for form in body do (process compiler form)
        finally (return (ops compiler))))

(defun optimize-static-output (ops)
    (let ((new-ops (make-op-buffer)))
        (with-output-to-string (buf)
            (flet ((add-op (op)
                       (compile-buffer buf new-ops)
                       (push-op op new-ops)))
            (loop for op across ops do
                (ecase (first op)
                    (:raw-string (write-sequence (second op) buf))
                    ((:newline :embed-value :embed-code) (add-op op))
                    ((:indent :unindent :freshline :toggle-indenting)
                        (when *pretty* (add-op op)))))
            (compile-buffer buf new-ops)))
        new-ops))

(defun compile-buffer (buf ops)
    (loop with str = (get-output-stream-string buf)
        for start = 0 then (1+ pos)
        for pos = (position #\Newline str :start start)
        when (< start (length str))
        do (push-op `(:raw-string ,(subseq str start pos) nil) ops)
        when pos do (push-op '(:newline) ops)
        while pos))

(defun generate-code (ops)
    (loop for op across ops collect (apply #'op->code op)))

(defgeneric op->code (op &rest operands))

(defmethod op->code ((op (eql :raw-string)) &rest operands)
    (destructuring-bind (string check-for-newlines) operands
        (if *pretty*
            `(raw-string *html-pretty-printer* ,string ,check-for-newlines)
            `(write-sequence ,string *html-output*))))

(defmethod op->code ((op (eql :newline)) &rest operands)
    (declare (ignorable operands))
    (if *pretty*
        '(newline *html-pretty-printer*)
        '(write-char #\Newline *html-output*)))

(defmethod op->code ((op (eql :freshline)) &rest operands)
    (declare (ignorable operands))
    (if *pretty*
        '(freshline *html-pretty-printer*)
        (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :indent)) &rest operands)
    (declare (ignorable operands))
    (if *pretty*
        '(indent *html-pretty-printer*)
        (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :unindent)) &rest operands)
    (declare (ignorable operands))
    (if *pretty*
        '(unindent *html-pretty-printer*)
        (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :toggle-indenting)) &rest operands)
    (declare (ignorable operands))
    (if *pretty*
        '(toggle-indenting *html-pretty-printer*)
        (error "Bad op when not pretty-printing: ~a" op)))

(defmethod op->code ((op (eql :embed-value)) &rest operands)
    (destructuring-bind (value escapes) operands
        (if *pretty*
            (if escapes
                `(raw-string *html-pretty-printer* 
                    (escape (any->string ,value) ,escapes) t)
                `(raw-string *html-pretty-printer*
                    (any->string ,value) t))
            (if escapes
                `(write-sequence (escape (any->string ,value) ,escapes) 
                                 *html-output*)
                `(princ ,value *html-output*)))))

(defmethod op->code ((op (eql :embed-code)) &rest operands)
    (first operands))

(defun special-form-p (form)
    (and (consp form) 
         (symbolp (car form)) 
         (get (car form) 'html-special-operator)))

(defmacro define-html-special-operator (name (processor &rest other-parameters) 
                                        &body body)
    `(eval-when (:compile-toplevel :load-toplevel :execute)
        (setf (get ',name 'html-special-operator)
              (lambda (,processor ,@other-parameters) ,@body))))

(define-html-special-operator :noescape (processor &rest body)
    (let ((*escapes* nil))
        (loop for exp in body do (process processor exp))))

(define-html-special-operator :attribute (processor &rest body)
    (let ((*escapes* *attribute-escapes*))
        (loop for exp in body do (process processor exp))))

(define-html-special-operator :print (processor &rest form)
    (cond
        ((self-evaluating-p form)
            (warn "Redundant :print of self-evaluating form ~s" form)
            (process-sexp-html processor form))
        (t (embed-value processor form))))

(define-html-special-operator :format (processor &rest args)
    (if (every #'self-evaluating-p args)
        (process-sexp-html processor (apply #'format nil args))
        (embed-value processor `(format nil ,@args))))

(define-html-special-operator :newline (processor)
    (newline processor))

(define-html-special-operator :progn (processor &rest body)
    (loop for exp in body do (process processor exp)))

(defun process-special-form (processor form)
    (apply (get (car form) 'html-special-operator) processor form))

(defun macro-form-p (form)
    (cons-form-p form (lambda (x) (and (symbolp x) (get x 'html-macro)))))

(defun parse-html-macro-lambda-list (args)
    (let ((attr-cons (member '&attributes args)))
        (values
            (cadr attr-cons)
            (nconc (ldiff args attr-cons) (cddr attr-cons)))))

(defmacro define-html-macro (name (&rest args) &body body)
    (multiple-value-bind (attribute-var args) 
                         (parse-html-macro-lambda-list args)
        (if attribute-var
            (generate-macro-with-attributes name attribute-var args body)
            (generate-macro-no-attributes name args body))))

(defun generate-macro-with-attributes (name attribute-args args body)
    (with-gensyms (attributes form-body)
        (if (symbolp attribute-args) 
            (setf attribute-args `(&rest attribute-args)))
        `(eval-when (:compile-toplevel :load-toplevel :execute)
            (setf (get ',name 'html-macro-wants-attributes) t)
            (setf (get ',name 'html-macro)
                (lambda (,attributes ,form-body)
                    (destructuring-bind (,@attribute-args) ,attributes
                        (destructuring-bind (,@args) ,form-body 
                            ,@body)))))))

(defun generate-macro-no-attributes (name args body)
    (with-gensyms (form-body)
        `(eval-when (:compile-toplevel :load-toplevel :execute)
            (setf (get ',name 'html-macro-wants-attributes) nil)
            (setf (get ',name 'html-macro)
                (lambda (,form-body)
                    (destructuring-bind (,@args) ,form-body
                        ,@body))))))

(defun expand-macro-form (form)
    (if (or (consp (first form))
            (get (first form) 'html-macro-wants-attributes))
        (multiple-value-bind (tag attributes body) 
                             (parse-cons-form form)
            (funcall (get tag 'html-macro) attributes body))
        (destructuring-bind (tag &body body) form
            (funcall (get tag 'html-macro) body))))

(defmacro in-html-style (syntax)
    (eval-when (:compile-toplevel :load-toplevel :execute)
        (case syntax
            (:html (setf *xhtml* nil))
            (:xhtml (setf *xhtml* t)))))

(defun codegen-html (ops pretty)
    (let ((*pretty* pretty))
        `(progn ,@(generate-code (optimize-static-output ops)) nil)))

(defmacro html (&whole whole &body body)
    (declare (ignorable body))
    `(if *pretty*
        (macrolet ((html (&body body) (codegen-html (sexp->ops body) t)))
            (let ((*html-pretty-printer* (get-pretty-printer))) ,whole))
        (macrolet ((html (&body body) (codegen-html (sexp->ops body) nil)))
            ,whole)))

(show-exports *package*)

;;; test
(defvar html-str'(:html 
                (:head (:title "Hello World")) 
                (:body (:h1 "Hello World")
                       (:hr))))
(emit-html html-str)

(setf *html-pretty-printer* (get-pretty-printer 4))
(html (:html 
         (:head (:title "Hello World")) 
         (:body (:h1 "Hello World")
                (:hr))))

(setf *pretty* nil)
(emit-html html-str)
(html (:html 
         (:head (:title "Hello World")) 
         (:body (:h1 "Hello World")
                (:hr))))


